home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / dtadmo / module1.bas < prev    next >
BASIC Source File  |  1994-10-15  |  14KB  |  504 lines
  1. 'copyright (c) 1994 by Bruce Fulton
  2. 'All Rights Reserved
  3. 'You may use this program for your own education
  4. 'and information, and you may give a copy of the program,
  5. 'completely intact, to others to help them learn, but
  6. 'you may not charge for the program nor may you charge
  7. 'any fee for copying it for others.
  8. Option Explicit
  9.  
  10. 'program declarations
  11. Global ThePath As String
  12. Global Const MB_YESNO = 4              ' Yes and No buttons
  13. Global Const IDYES = 6                 ' Yes button pressed
  14. Global Const MB_DEFBUTTON2 = 256       ' Second button is default
  15.  
  16.  
  17. ' from the data.txt constant file
  18. ' Data Access constants
  19. ' not all of these are used in this program
  20. '
  21. ' Option argument values (CreateDynaset, etc)
  22. Global Const DB_DENYWRITE = &H1
  23. Global Const DB_DENYREAD = &H2
  24. Global Const DB_READONLY = &H4
  25. Global Const DB_APPENDONLY = &H8
  26. Global Const DB_INCONSISTENT = &H10
  27. Global Const DB_CONSISTENT = &H20
  28. Global Const DB_SQLPASSTHROUGH = &H40
  29.  
  30. ' SetDataAccessOption
  31. Global Const DB_OPTIONINIPATH = 1
  32.  
  33. ' Field Attributes
  34. Global Const DB_FIXEDFIELD = &H1
  35. Global Const DB_VARIABLEFIELD = &H2
  36. Global Const DB_AUTOINCRFIELD = &H10
  37. Global Const DB_UPDATABLEFIELD = &H20
  38.  
  39. ' Field Data Types
  40. Global Const DB_BOOLEAN = 1
  41. Global Const DB_BYTE = 2
  42. Global Const DB_INTEGER = 3
  43. Global Const DB_LONG = 4
  44. Global Const DB_CURRENCY = 5
  45. Global Const DB_SINGLE = 6
  46. Global Const DB_DOUBLE = 7
  47. Global Const DB_DATE = 8
  48. Global Const DB_TEXT = 10
  49. Global Const DB_LONGBINARY = 11
  50. Global Const DB_MEMO = 12
  51.  
  52. ' TableDef Attributes
  53. Global Const DB_ATTACHEXCLUSIVE = &H10000
  54. Global Const DB_ATTACHSAVEPWD = &H20000
  55. Global Const DB_SYSTEMOBJECT = &H80000002
  56. Global Const DB_ATTACHEDTABLE = &H40000000
  57. Global Const DB_ATTACHEDODBC = &H20000000
  58.  
  59. ' ListTables TableType
  60. Global Const DB_TABLE = 1
  61. Global Const DB_QUERYDEF = 5
  62.  
  63. ' ListTables Attributes (for QueryDefs)
  64. Global Const DB_QACTION = &HF0
  65. Global Const DB_QCROSSTAB = &H10
  66. Global Const DB_QDELETE = &H20
  67. Global Const DB_QUPDATE = &H30
  68. Global Const DB_QAPPEND = &H40
  69. Global Const DB_QMAKETABLE = &H50
  70.  
  71. ' ListIndexes IndexAttributes values
  72. Global Const DB_UNIQUE = 1
  73. Global Const DB_PRIMARY = 2
  74. Global Const DB_PROHIBITNULL = 4
  75. Global Const DB_IGNORENULL = 8
  76. ' ListIndexes FieldAttributes value
  77. Global Const DB_DESCENDING = 1  'For each field in Index
  78.  
  79. ' CreateDatabase and CompactDatabase Language constants
  80. Global Const DB_LANG_GENERAL = ";LANGID=0x0809;CP=1252;COUNTRY=0"
  81. Global Const DB_LANG_SPANISH = ";LANGID=0x040A;CP=1252;COUNTRY=0"
  82. Global Const DB_LANG_DUTCH = ";LANGID=0x0413;CP=1252;COUNTRY=0"
  83. Global Const DB_LANG_SWEDFIN = ";LANGID=0x040C;CP=1252;COUNTRY=0"   'VB3 andAccess 1.1 Databases
  84. Global Const DB_LANG_NORWDAN = ";LANGID=0x0414;CP=1252;COUNTRY=0"   'VB3 andAccess 1.1 Databases
  85. Global Const DB_LANG_ICELANDIC = ";LANGID=0x040F;CP=1252;COUNTRY=0" 'VB3 andAccess 1.1 Databases
  86. Global Const DB_LANG_NORDIC = ";LANGID=0x041D;CP=1252;COUNTRY=0"    'Access 1.0 Databases only
  87.  
  88. ' CreateDatabase and CompactDatabase options
  89. Global Const DB_VERSION10 = 1        ' Microsoft Access Version 1.0
  90. Global Const DB_ENCRYPT = 2          ' Make database encrypted.
  91. Global Const DB_DECRYPT = 4          ' Decrypt database while compacting.
  92.  
  93. 'Collating order values
  94. Global Const DB_SORTGENERAL = 256    ' Sort by EFGPI rules (English, French,  German,Portuguese, Italian)
  95. Global Const DB_SORTSPANISH = 258    ' Sort by Spanish rules
  96. Global Const DB_SORTDUTCH = 259      ' Sort by Dutch rules
  97. Global Const DB_SORTSWEDFIN = 260    ' Sort by Swedish, Finnish rules
  98. Global Const DB_SORTNORWDAN = 261    ' Sort by Norwegian, Danish rules
  99. Global Const DB_SORTICELANDIC = 262  ' Sort by Icelandic rules
  100. Global Const DB_SORTPDXINTL = 4096   ' Sort by Paradox international rules
  101. Global Const DB_SORTPDXSWE = 4097    ' Sort by Paradox Swedish, Finnish rules
  102. Global Const DB_SORTPDXNOR = 4098    ' Sort by Paradox Norwegian, Danish rules
  103. Global Const DB_SORTUNDEFINED = -1   ' Sort rules are undefined or unknown
  104.  
  105. Sub addfield ()
  106.     'turn on the errorhandler
  107.     On Error GoTo addfieldERR
  108.     screen.MousePointer = 11
  109.     
  110.     'dim variables as a database and field objects
  111.     Dim db As database
  112.     Dim newf As New field
  113.  
  114.     'define the name, the type and if applicable,
  115.     'the length and attributes for the field.
  116.     newf.Name = "Comment"
  117.     newf.Type = DB_MEMO
  118.     'open the database
  119.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  120.     'add the new field to the Place Names table in the database
  121.     db.TableDefs("Place Names").Fields.Append newf
  122.     'close the database
  123.     db.Close
  124.     screen.MousePointer = 0
  125.     MsgBox "Field 'Comments' successfully added to Place Names."
  126.     
  127.     
  128. 'error trapping routine
  129. GoTo addfieldEND
  130. addfieldERR:
  131.     showerror
  132.     Resume addfieldEND
  133. addfieldEND:
  134. screen.MousePointer = 0
  135.  
  136. End Sub
  137.  
  138. Sub additems (lbl As Label)
  139. 'turn on error trapping
  140. On Error GoTo additemsERR
  141. screen.MousePointer = 11
  142.  
  143. 'declare needed variables
  144. Dim filnam, lin As String
  145. Dim db As database, tb As table
  146. Dim elapsed, itmcnt As Long
  147.  
  148. 'open the database
  149. Set db = OpenDatabase(ThePath + "USPLACE.MDB", True)
  150. 'select/open the table to add to
  151. Set tb = db.OpenTable("Place Names")
  152.  
  153. 'we'll read data in from a
  154. 'fixed field ascii file and add it to the mdb database.
  155. 'You could also load from other file formats or from
  156. 'values in text boxes.
  157. filnam = ThePath + "sample.dta"
  158. Open filnam For Input As #1
  159. 'just skip any duplicate key errors
  160. On Error Resume Next
  161. 'let's see how long it takes
  162. elapsed = Timer
  163. While Not EOF(1)
  164.     'experiment with adding or commenting out the
  165.     'following two statements to see the performance
  166.     'hit!
  167.     
  168.     'DoEvents
  169.     'FreeLocks
  170.     
  171.     'use the addnew method
  172.     tb.AddNew
  173.         Line Input #1, lin
  174.         tb("Name") = Trim$(Mid$(lin, 1, 48))
  175.         lbl.Caption = "Adding " & tb("Name")
  176.         tb("State Code") = Val(Mid$(lin, 60, 2))
  177.         tb("County Code") = Val(Mid$(lin, 62, 3))
  178.         'str2dec converts latitude/longitude
  179.         'in dddhhmm format to decimal format
  180.         tb("Latitude") = str2dec(Mid$(lin, 73, 6))
  181.         tb("Longitude") = str2dec(Mid$(lin, 80, 7))
  182.     'if you don't 'update', the data is not added
  183.     tb.Update
  184.     If Err <> 0 Then
  185.         lbl.Caption = "ERROR - did not add " & tb("Name")
  186.         Err = 0
  187.     Else
  188.         'just counting how many items we've done
  189.         itmcnt = itmcnt + 1
  190.     End If
  191.     'save some time by commenting out the label refresh
  192.     'command
  193.     lbl.Refresh
  194. Wend
  195.  
  196. 'restore regular error handler and close everything
  197. On Error GoTo additemsERR
  198. tb.Close
  199. db.Close
  200. Close #1
  201. form1.Label3.Caption = ""
  202. screen.MousePointer = 0
  203. 'how did we do?
  204. elapsed = Timer - elapsed
  205. MsgBox Str$(itmcnt) & " items successfully added in " & Str$(elapsed) & " seconds."
  206.  
  207. 'error trapping routine
  208. GoTo additemsEND
  209. additemsERR:
  210.     showerror
  211.     Resume additemsEND
  212. additemsEND:
  213. screen.MousePointer = 0
  214. End Sub
  215.  
  216. Sub addnameidx ()
  217.     'turn on the errorhandler
  218.     On Error GoTo addnameidxERR
  219.     screen.MousePointer = 11
  220.     
  221.     'dim database, new index objects
  222.     Dim db As database
  223.     Dim ix As New Index
  224.     Dim elapsed
  225.     'name the new table
  226.     ix.Name = "Name Index"
  227.     ix.Fields = "Name"
  228.     ix.Unique = False
  229.     ix.Primary = False
  230.     'let's see how long it took
  231.     elapsed = Timer
  232.     'open the database
  233.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  234.     'add the new table to the database
  235.     db.TableDefs("Place Names").Indexes.Append ix
  236.     'close the database
  237.     db.Close
  238.     elapsed = Timer - elapsed
  239.     screen.MousePointer = 0
  240.     MsgBox "Secondary index on Name for table Place Names successfully created. It took " & Str$(elapsed) & " seconds."
  241.  
  242. 'error trapping routine
  243. GoTo addnameidxEND
  244. addnameidxERR:
  245.     showerror
  246.     Resume addnameidxEND
  247. addnameidxEND:
  248. screen.MousePointer = 0
  249.  
  250. End Sub
  251.  
  252. Sub addtucson ()
  253. 'turn on error trapping
  254. On Error GoTo addtucsonERR
  255. screen.MousePointer = 11
  256.  
  257. 'declare needed variables
  258. Dim db As database, tb As table
  259.  
  260. 'open the database
  261. Set db = OpenDatabase(ThePat